home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / mosmllib / Path.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  8.5 KB  |  251 lines  |  [TEXT/Moml]
  1. (* Path 6 -- new basis 1995-04-28, 1995-06-06, 1996-10-13 *)
  2.  
  3. exception Path
  4.  
  5. (* It would make sense to use substrings for internal versions of
  6.  * fromString and toString, and to allocate new strings only when 
  7.  * externalizing the strings.
  8.  
  9.  * Impossible cases: 
  10.    UNIX: {isAbs = false, vol = _, arcs = "" :: _}
  11.    Mac:  {isAbs = true,  vol = _, arcs = "" :: _}
  12. *)
  13.  
  14. local 
  15.     val op @ = List.@
  16.     infix 9 sub
  17.     val op sub = String.sub
  18.     val substring = String.extract
  19.  
  20. (* Modified extensively for Macintosh pathnames - 1995-09-17 e *)
  21.  
  22. (* Mac pathnames differ from UNIX pathnames in many respects.
  23.    It is generally impossible to tell from the Mac pathname itself
  24.    - if the path is relative or absolute
  25.    - if the path refers to a file or directory
  26.  
  27.    Slash is spelled ":"
  28.    The root of the directory tree is referred to as "" and is an absolute
  29.    path; otherwise, any name with no colons is considered a relative path.
  30.    A name staring with a colon is always a relative path.
  31.    A name ending in a colon is always a directory path.
  32.  
  33.    There are no special file names such as "." or ".."
  34.    ":" is the current directory
  35.    "::" is up one from the current directory
  36.    ":::" is up two from the current directory, etc.
  37.    ":a::b" = ":b", "a::b:" = "b:"
  38.  
  39.    It is safer to always include a colon in the pathname if you can.
  40.    For example, instead of "foo" for a directory name
  41.                        use "foo:"  to refer to the absolute path
  42.                        use ":foo:" to refer to the relative path
  43.    even though MacOS would allow all three names for the relative path.
  44.  
  45.   A pathname without colons is consider relative. This is what one usually
  46.   wants (plain file names are looked for in the current directory first).
  47.   This leads to odd behavior; e.g., (isCanonical "a") is false, and 
  48.   (base "a.b") is ":a" -- oh well, it tends to work even if it looks weird.
  49. *)
  50.  
  51. val slash = ":"
  52. val volslash = ""
  53. val relslash = ":"
  54. fun isslash c = c = #":"
  55. fun validVol s = s = ""
  56.  
  57. (* empty name ""  => absolute
  58.    first char ":" => relative
  59.    other char ":" => absolute
  60.    else, I picked => relative
  61. *)
  62. fun splitabsvolrest s =
  63.   let val sz = size s
  64.   in
  65.     if       sz = 0           then (true,  "", s)
  66.     else if isslash (s sub 0) then (false, "", substring(s, 1, NONE))
  67.     else let fun hasslash n =
  68.            if n <= 0 then (false, "", s)
  69.            else if isslash (s sub n)
  70.                 then (true, "", s)
  71.                 else hasslash (n-1)
  72.          in hasslash (sz - 1) end
  73.   end
  74.  
  75. in
  76.  
  77. val parentArc  = ""   (* not always! *)
  78. val currentArc = "."  (* not really! *)
  79.  
  80. fun isAbsolute p = #1 (splitabsvolrest p)
  81.  
  82. fun isRelative p = not (isAbsolute p);
  83.  
  84. fun fromString p = 
  85.     case splitabsvolrest p of
  86.         (true,  v,   "") => {isAbs=true,  vol = v, arcs = []}
  87.       | (isAbs, v, rest) => {isAbs=isAbs, vol = v, 
  88.                              arcs = String.fields isslash rest};
  89.  
  90. fun isRoot p = 
  91.     case splitabsvolrest p of
  92.         (true, _, "") => true
  93.       | _             => false;
  94.  
  95. fun getVolume p = #2 (splitabsvolrest p);
  96. fun validVolume{isAbs, vol} = validVol vol;
  97.  
  98. fun toString (path as {isAbs, vol, arcs}) =
  99.     let fun h []        res = res 
  100.           | h (a :: ar) res = h ar (a :: slash :: res)
  101.     in  
  102.         if validVolume{isAbs=isAbs, vol=vol} then 
  103.             case (isAbs, arcs) of
  104.                 (false, []         ) => vol ^ relslash
  105.               | (false, [a]        ) => (* special case for simple filenames *)
  106.                                         if a = "" then ":" else a
  107.               | (false, a1 :: arest) => 
  108.                     String.concat (List.rev (h arest [a1, relslash, vol]))
  109.               | (true,  []         ) => vol ^ volslash
  110.               | (true, a1 :: arest ) => 
  111.                     String.concat (List.rev (h arest [a1, volslash, vol])) 
  112.         else
  113.             raise Path
  114.     end;
  115.  
  116. fun concat (p1, p2) =
  117.     let fun stripslash path = 
  118.             let val sz = size path
  119.             in if sz > 0 andalso isslash (path sub (sz - 1)) then
  120.                    substring(path, 0, SOME(sz - 1))
  121.                else path
  122.             end
  123.         val p2' = 
  124.             if size p2 > 0 andalso isslash (p2 sub 0)
  125.             then substring(p2, 1, NONE)
  126.             else p2
  127.     in
  128.         if p2 <> "" andalso isAbsolute p2 then raise Path
  129.         else
  130.             case splitabsvolrest p1 of
  131.                 (false, "",   "") =>     relslash ^ p2'
  132.               | (false, v,  path) => v ^ relslash ^ stripslash path ^ slash ^ p2'
  133.               | (true,  v,  ""  ) => v ^ volslash ^ p2'
  134.               | (true,  v,  path) => v ^ volslash ^ stripslash path ^ slash ^ p2'
  135.     end;
  136.  
  137. fun getParent p =
  138.     let open List
  139.         fun getpar xs = 
  140.             rev (case rev xs of
  141.                      []                  => []         
  142.                    | "" :: "" :: revrest => "" :: "" :: "" :: revrest
  143.                    | "" ::  _ :: revrest => "" :: revrest
  144.                    |       "" ::      [] => ["",""]
  145.                    |        _ :: revrest => "" :: revrest)
  146.         val {isAbs, vol, arcs} = fromString p 
  147.     in
  148.         case getpar arcs of 
  149.             []   => 
  150.                 if isAbs then toString {isAbs=true, vol=vol, arcs=[]}
  151.                 else ":"
  152.           | arcs => toString {isAbs=isAbs, vol=vol, arcs=arcs}
  153.     end;
  154.  
  155. fun canonize p =
  156.     let val {isAbs, vol, arcs} = fromString p 
  157.         fun lastup []                 = if isAbs then [] else [""]
  158.           | lastup ( "" :: res) = "" :: "" :: res
  159.           | lastup (       res) = "" :: res
  160.         fun backup []                 = if isAbs then [] else [""]
  161.           | backup ( "" :: res) = "" :: "" :: res
  162.           | backup ( _  :: res) = res
  163.         fun reduce arcs = 
  164.             let fun h []           []  = if isAbs then [] else [""]
  165.                   | h []           res =             res
  166.                   | h (""::[])     res =      (lastup res)
  167.                   | h (""::ar)     res = h ar (backup res)
  168.                   | h (a1::ar)     res = h ar (a1 :: res)
  169.             in h arcs [] end
  170.     in
  171.         {isAbs=isAbs, vol=vol, arcs=List.rev (reduce arcs)}
  172.     end;
  173.  
  174. fun mkCanonical p = toString (canonize p);
  175.  
  176. fun parentize      []  = []
  177.   | parentize (""::[]) = []
  178.   | parentize (_ ::ar) = "" :: parentize ar;
  179.  
  180. fun parentize' ar = "" :: parentize ar;
  181.  
  182. fun mkRelative (p1, p2) =
  183.     case (fromString p1, canonize p2) of
  184.         (_ ,                {isAbs=false,...}) => raise Path
  185.       | ({isAbs=false,...}, _                ) => p1
  186.       | ({vol=vol1, arcs=arcs1,...}, {vol=vol2, arcs=arcs2, ...}) =>
  187.             let fun h []      []  = [""]
  188.                   | h a1      []  = a1
  189.                   | h a1 (""::[]) = a1
  190.                   | h (""::[]) a2 = parentize' a2
  191.                   | h      []  a2 = parentize' a2
  192.                   | h (a1 as (a11::a1r)) (a2 as (a21::a2r)) =
  193.                     if a11=a21 then h a1r a2r
  194.                     else parentize a2 @ a1
  195.             in
  196.                 if vol1 <> vol2 then raise Path 
  197.                 else toString {isAbs=false, vol="", arcs=h arcs1 arcs2}
  198.             end;
  199.  
  200. fun mkAbsolute (p1, p2) =
  201.     if isRelative p2 then raise Path
  202.     else if isAbsolute p1 then p1
  203.     else mkCanonical(concat(p2, p1));
  204.  
  205. fun isCanonical p = mkCanonical p = p;
  206.  
  207. fun joinDirFile {dir, file} = concat(dir, file)
  208.  
  209. fun splitDirFile p =
  210.     let open List
  211.         val {isAbs, vol, arcs} = fromString p 
  212.     in
  213.         case rev arcs of
  214.             []            => 
  215.                 {dir = toString {isAbs=isAbs, vol=vol, arcs=[]}, file = ""  }
  216.           | "" :: _       => 
  217.                 {dir = toString {isAbs=isAbs, vol=vol, arcs=arcs}, file = ""}
  218.           | arcn :: [] => 
  219.                 {dir = "", file = arcn}
  220.           | arcn :: farcs => 
  221.                 {dir = toString {isAbs=isAbs, vol=vol, arcs=rev ("" :: farcs)}, 
  222.                  file = arcn}
  223.     end
  224.  
  225. fun dir s  = #dir (splitDirFile s);
  226. fun file s = #file(splitDirFile s);
  227.  
  228. fun joinBaseExt {base, ext = NONE}    = base
  229.   | joinBaseExt {base, ext = SOME ""} = base
  230.   | joinBaseExt {base, ext = SOME ex} = base ^ "." ^ ex;
  231.  
  232. fun splitBaseExt s =
  233.     let val {dir, file} = splitDirFile s
  234.         open Substring 
  235.         val (fst, snd) = splitr (fn c => c <> #".") (all file)
  236.     in 
  237.         if isEmpty snd         (* dot at right end     *) 
  238.            orelse isEmpty fst  (* no dot               *)
  239.            orelse size fst = 1 (* dot at left end only *) 
  240.             then {base = s, ext = NONE}
  241.         else 
  242.             {base = joinDirFile{dir = dir, 
  243.                                 file = string (trimr 1 fst)},
  244.              ext = SOME (string snd)}
  245.     end;
  246.  
  247. fun ext s  = #ext  (splitBaseExt s);
  248. fun base s = #base (splitBaseExt s);
  249.  
  250. end
  251.